home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / pascal / wctunits.zip / XCRT.PAS < prev    next >
Pascal/Delphi Source File  |  1991-07-30  |  17KB  |  589 lines
  1. unit xcrt;
  2.  
  3. { Written by William C. Thompson (wct@po.cwru.edu) - 1991
  4.   Parts of this unit were taken from HTScreen, written by
  5.   Harold Thunem. }
  6.  
  7. { If anyone has an idea for a procedure, please E-mail and I
  8.   will consider including it in my unit.  It should be something
  9.   that you do often. }
  10.  
  11. (* Features to be added:
  12.   Another unit containing definitions for different musical tones *)
  13.  
  14. { Designer's Notes:
  15.   1. This unit was written was with the goal of making tedious crt
  16.      routines much more bearable by modularizing the entire process.
  17.      Another goal is to make the routines very fast by directly
  18.      affecting memory.  Consequently, much of the error checking has
  19.      been left out.  The user is responsible for error checking his
  20.      own code.  In many cases this proves to give the user more
  21.      control, and there is little or no overhead if the code was
  22.      written with some care.  For example, many times a rectangle
  23.      is defined by (x1,y1) & (x2,y2) which represent the upper-left
  24.      and lower-right corners, respectively.  If x1>x2 or y1>y2 the
  25.      call is often ignored.
  26.   2. When setting foreground colors, you can set the blink constant
  27.      by adding 128 (pre-defined as 'blink') to the foreground color.
  28.   3. As yet, this unit is only designed to handle screens with
  29.      80 columns.  Including checking for 40 columns would slow
  30.      down the procedures which are intended to be very fast.
  31.      A program using 40 columns could easily borrow the ideas
  32.      used in this unit.  I have confirmed that they do work for
  33.      43/50 rows.  Many don't work for 40 columns.
  34.   4. All window-like procedures are in absolute coordinates.  Once
  35.      again, it up to the user to maintain relative coordinates
  36.      somehow (it is not very difficult) because that would slow down
  37.      the routines for other uses.
  38.   5. My apologies for my somewhat abnormal style of indentation, but
  39.      at least it is consistent (unlike some other code I have seen).
  40.      You may also notice that I avoid white spaces and capitalization
  41.      with a passion.  It seems very silly to worry about how many
  42.      spaces I have put between variables, so I don't put any unless
  43.      absolutely necessary.  I do try to keep my commenting neat, when
  44.      convenient. }
  45.  
  46. interface
  47.  
  48. uses crt,dos,keydef;
  49.  
  50. const
  51.   blackbg=$00;
  52.   bluebg=$10;
  53.   greenbg=$20;
  54.   cyanbg=$30;
  55.   redbg=$40;
  56.   magentabg=$50;
  57.   brownbg=$60;
  58.   lightgraybg=$70;
  59.  { Setting the text color and background color at the same time can
  60.    be very tedious.  You have to say TextColor(X) and TextBackGround(Y),
  61.    which is much too much typing.  You can also be clever and set
  62.    TextAttr:=Y*16+X, which is a pain.  This can be made simpler by
  63.    setting TextAttr:=YBG+X, which sets the background color at the
  64.    same with a minimum of typing.  It also lets you avoid trying to
  65.    set background colors to 8-15, something that I have tried often.
  66.    More importantly, it makes it clearer to see what is happening.
  67.  
  68.    For example, instead of
  69.  
  70.    TextColor(White); TextBackGround(Cyan) or TextAttr:=Cyan*16+White,
  71.  
  72.    much simpler would be
  73.  
  74.    TextAttr:=CyanBG+White.
  75.  
  76.     If you wish to set only the background or foreground color (but
  77.     not both), you can still use TextColor and TextBackGround. }
  78.  
  79.   { Text fonts, 25 or 43/50 rows }
  80.   ega43font=1;
  81.   normalfont=2;
  82.  
  83.  { border constants }
  84.   noborder=0;
  85.   singleborder=1;
  86.   doubleborder=2;
  87.   dtopsside=3;
  88.   stopdside=4;
  89.  
  90.  { textline constants }
  91.   thinhoriz=0;
  92.   thinvert=1;
  93.   thickhoriz=2;
  94.   thickvert=3;
  95.  
  96. type
  97.   screenpt=^screen;
  98.   screen=array[0..3999] of word;
  99.   { This is a maximum size for a screen - 80 columns * 50 rows = 4000.
  100.     The maximum space required would then be 8000 bytes. }
  101.   block=record
  102.     rows,cols: word;
  103.     sp: screenpt
  104.     end;
  105.   getoneofstring=string[120];
  106.   writexystring=string[80];
  107.  
  108. var
  109.   badkeybeep: boolean;     { beep when a bad is pressed? }
  110.   badkeyhz: word;          { sound to emit for bad key }
  111.   badkeydur: word;         { duration of bad key beep }
  112.   goodkeybeep: boolean;    { beep when a good key is pressed }
  113.   goodkeyhz: word;         { sound to emit for good key }
  114.   goodkeydur: word;        { duration of good key beep }
  115.   cursorinitial, cursoroff, cursorunderline,
  116.     cursorhalfblock, cursorblock: word;    { cursor settings }
  117.   preserveattr: boolean;
  118.   { If preserveattr=true, putch will preserve the attribute settings
  119.     for a location on the screen.  If preserveattr=false (default),
  120.     it will change the color attributes to the setting held in
  121.     textattr. }
  122.   crtrows,                 { Number of rows }
  123.   crtcols,                 { Number of columns }
  124.   videomode:byte;          { Video-mode }
  125.  
  126. procedure beep(hz,dur: word);
  127. function getch(x,y: byte):char;
  128. function getattr(x,y: byte):byte;
  129. procedure putch(x,y: byte; c: char);
  130. procedure putattr(x,y:byte; attr:byte);
  131. function shadowattr(attr:byte):byte;
  132. procedure writexy(x,y: byte; s: writexystring);
  133. procedure rightjust(x,y: byte; s: writexystring);
  134. procedure centerjust(x,y:byte; s:writexystring);
  135. procedure textbox(x1,y1,x2,y2: word; border:byte);
  136. procedure textline(startat,endat,c:word; attr:byte);
  137. procedure colorblock(x1,y1,x2,y2: word; c:byte);
  138. procedure fillblock(x1,y1,x2,y2:word; ch:char);
  139. procedure shadowblock(x1,y1,x2,y2:word);
  140. procedure attrblock(x1,y1,x2,y2:word; attr:byte);
  141. procedure scrollblockup(x1,y1,x2,y2,wakeattr:byte);
  142. procedure scrollblockdown(x1,y1,x2,y2,wakeattr:byte);
  143. procedure explodeblock(x1,y1,x2,y2:byte);
  144. function readallkeys:char;
  145. function yesorno:char;
  146. function getoneof(s:getoneofstring):char;
  147. function getcursor:word;
  148. procedure setcursor(curs:word);
  149. procedure savewindow(x1,y1,x2,y2: word; var w: block);
  150. procedure killwindow(var w:block);
  151. procedure recallwindow(x1,y1:word; var w: block);
  152. function getfont:byte;
  153. procedure setfont(font:byte);
  154. function getvideomode:byte;
  155. procedure setvideomode(mode:byte);
  156. procedure xcrtinit;
  157.  
  158. implementation
  159.  
  160. const
  161.   borders:array[0..4] of string[6]=('      ',
  162.                                     '┌─┐│┘└',
  163.                                     '╔═╗║╝╚',
  164.                                     '╒═╕│╛╘',
  165.                                     '╓─╖║╜╙');
  166.  
  167. var
  168.   regs: registers;
  169.   videoseg: word;        { Video segment address }
  170.  
  171. procedure beep(hz,dur: word);
  172. begin
  173.   sound(hz);
  174.   delay(dur);
  175.   nosound
  176. end;
  177.  
  178. function getch(x,y: byte):char;
  179. { returns character at absolute position (x,y) through memory
  180.   The error checking has been removed to speed up function }
  181. begin
  182.   getch:=char(mem[videoseg:(160*y+2*x-162)]);    { 2*80*(y-1)+2*(x-1) }
  183. end;
  184.  
  185. function getattr(x,y: byte):byte;
  186. { returns color attribute at absolute position (x,y) through memory
  187.   The error checking has been removed to speed up function }
  188. begin
  189.   getattr:=mem[videoseg:(160*y+2*x-161)];    { 2*80*(y-1)+2*(x-1)+1 }
  190. end;
  191.  
  192. procedure putch(x,y: byte; c: char);
  193. { QUICKLY writes c to absolute position (x,y) through memory
  194.   This is at least 10 times faster than a gotoxy(x,y), write(c)
  195.   Another bonus is that the cursor doesn't move.
  196.   The error checking has been removed  }
  197. begin
  198.   if not preserveattr then
  199.     memw[videoseg:(160*y+2*x-162)]:=textattr shl 8+ord(c)
  200.   else mem[videoseg:(160*y+2*x-162)]:=ord(c)
  201. end;
  202.  
  203. procedure putattr(x,y,attr: byte);
  204. { Directly change the color attributes of char at absolute screen (x,y) }
  205. begin
  206.   mem[videoseg:(160*y+2*x-161)]:=attr
  207. end;
  208.  
  209. function shadowattr(attr:byte):byte;
  210. { Returns an appropriate shadow attribute.  First it masks out the
  211.   upper four bits (background of shadow is always black) as well as
  212.   the 3rd bit (a shadow should be a dark color).  Unfortunately,
  213.   if the text color is black, you can't see it, so there is a
  214.   special case for that (sets it to lightgray). }
  215. var
  216.   temp: byte;
  217. begin
  218.   temp:=attr and $07;
  219.   if temp=black then shadowattr:=lightgray
  220.   else shadowattr:=temp
  221. end;
  222.  
  223. procedure writexy(x,y: byte; s: writexystring);
  224. { Writes string s at absolute (x,y) - left justified }
  225. var
  226.   i: byte;
  227. begin
  228.   for i:=1 to length(s) do putch(